home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / copyalloc.c < prev    next >
C/C++ Source or Header  |  1993-07-12  |  20KB  |  878 lines
  1.  /*    
  2.   * Allocation routines for feel
  3.   *
  4.   */
  5.  
  6. /* what we need to stay ahead*/
  7. #include "defs.h"
  8. #include "structs.h"
  9. #include "funcalls.h"
  10. #include "global.h"
  11. #include "allocate.h" 
  12. #include "error.h"
  13. #include "table.h"
  14. #include "threads.h" 
  15.  
  16. /* other junk */
  17. #include "copy.h"
  18.  
  19. #ifndef DEFAULT_HEAP_SIZE
  20. #define DEFAULT_HEAP_SIZE (4*1024*1024)
  21. #endif
  22.  
  23. #ifndef DEFAULT_STACK_SPACE_SIZE
  24. #define DEFAULT_STACK_SPACE_SIZE (1*1024*1024)
  25. #endif
  26.  
  27. #define N_SLOTS_IN_CLASS N_SLOTS_IN_STRUCT(struct class_structure)
  28. #define N_SLOTS_IN_THREAD N_SLOTS_IN_STRUCT(struct thread_structure)
  29.  
  30. #ifdef ALIGN8
  31. #define ROUNDTO 8
  32. #else
  33. #define ROUNDTO 8
  34. #endif
  35.  
  36. #define ROUND_ADDR(x) ((((int)x)&(ROUNDTO-1))==0 ? x : x+(ROUNDTO-((int)x&(ROUNDTO-1))))
  37.  
  38. #ifdef NODEBUG
  39. #define FPRINTF_GC_BUG(x) 
  40. #define GC_BUG(x)
  41. #else
  42. #define GC_BUG(x) x
  43. #define FPRINTF_GC_BUG(x) fprintf x
  44. #endif
  45.  
  46. LispObject static_ints;
  47. LispObject static_chars;
  48.  
  49. static void initialise_stack_space(int);
  50.  
  51. void runtime_initialise_allocator(LispObject *stacktop)
  52. {
  53.   extern void init_allocator(int);
  54.   extern int command_line_heap_size;
  55.   extern int command_line_stack_space_size;
  56.   extern int command_line_cons_percentage;
  57.   extern int command_line_cons_cut_off;
  58.  
  59.   int heap,stack_space;
  60.   
  61.   heap = (command_line_heap_size == 0
  62.             ? DEFAULT_HEAP_SIZE 
  63.             : command_line_heap_size);
  64.  
  65.   if (heap < 50)
  66.     heap=heap*1024*1024;
  67.  
  68.  
  69.   {
  70.     extern int command_line_cons_percentage;
  71.     extern int command_line_cons_cut_off;
  72.     
  73.     if (command_line_stack_space_size < 50)
  74.       command_line_stack_space_size = command_line_stack_space_size*1024*1024;
  75.  
  76.     stack_space = (command_line_stack_space_size == 0
  77.            ? DEFAULT_STACK_SPACE_SIZE
  78.            : command_line_stack_space_size);
  79.   }
  80.  
  81.   init_allocator(heap); /* ifdef CGC this does nothing */
  82.   initialise_stack_space(stack_space); /* and this calls gc_init() */
  83.  
  84.   /* so if CGC is defined, all the above does is call gc_init() */
  85.  
  86.   /* Really need a smarter way of doing these... --- like do them last */
  87.   add_root(&state_dynamic_env);
  88.   add_root(&state_last_continue);
  89.   add_root(&state_handler_stack);
  90.   add_root(&state_current_thread);
  91. }
  92.  
  93. char *allocate_space(LispObject *stacktop,int n)
  94. {
  95.   char* allocate_stack(LispObject *stacktop, int nbytes);  
  96.  
  97.   return allocate_stack(stacktop,n);
  98. }
  99.  
  100. void deallocate_space(LispObject*stacktop,char *addr,int siz)
  101. {
  102.   void deallocate_stack(LispObject *, char *, int);
  103.  
  104.   deallocate_stack(stacktop,addr,siz);
  105. }
  106. void runtime_initialise_collector(LispObject *stacktop)
  107. {
  108.  
  109. }
  110.  
  111. #define NOT_YET_DONE(name) \
  112. { fprintf(stderr,"%s: cannot alloc\n",name) ; return nil;}
  113.   
  114. LispObject Fn_cons(LispObject *stacktop)
  115. {
  116.   LispObject ans;
  117.  
  118.   ans = allocate_nbytes(stacktop+2,sizeof(struct cons_structure),TYPE_CONS); 
  119.   
  120.   lval_classof(ans)=Cons;
  121.   ans->CONS.car= *stacktop;
  122.   ans->CONS.cdr= *(stacktop+1);
  123.   
  124.   return ans;
  125. }
  126.  
  127. /* Optimised to allow easier code in a lot of places... */
  128. LispObject allocate_n_conses(LispObject *stacktop, int n)
  129. {    
  130.   LispObject xx;
  131.   int i;
  132. #if 1
  133. #ifdef DGC 
  134. Dunc --- this wont work with your stuff, right?
  135. #endif
  136.   LispObject tmp,prev;
  137.   struct cons_structure *ptr;
  138.  
  139.   xx=allocate_nbytes(stacktop,n*sizeof(struct cons_structure),TYPE_CONS);
  140.   ptr=&(xx->CONS);
  141.   prev=nil;
  142.  
  143.   for (i=0; i< n; i++)
  144.     {
  145.       tmp=(LispObject) ptr;
  146.       lval_typeof(tmp)=TYPE_CONS;
  147.       gcof(tmp)=current_space();
  148. #ifdef GENERATIONAL
  149.       ageof(tmp)=0;
  150. #endif
  151.       lval_classof(tmp)=Cons;
  152.       CAR(tmp)=nil;
  153.       CDR(tmp)=prev;
  154.       
  155.       prev=tmp;
  156.       ptr++;
  157.     }
  158.   
  159.   return (LispObject) tmp;
  160. #else
  161.   xx=nil;
  162.   for (i=0; i<n; i++)
  163.     {
  164.       xx=EUCALL_2(Fn_cons,nil,xx);
  165.     }
  166.       
  167.   return xx;
  168.  
  169. #endif
  170. }
  171.  
  172. LispObject allocate_n_envs(LispObject *stacktop, int n, LispObject last)
  173. {    
  174.   LispObject xx;
  175.   int i;
  176.   xx=last;
  177.   for (i=0; i< n; i++)
  178.     {
  179.       xx=allocate_env(stacktop,nil,nil,xx);
  180.     }
  181.  
  182.   return xx;
  183. }
  184.  
  185. LispObject allocate_class(LispObject *stacktop,LispObject class)
  186. {    /* Really the same as allocate_integer, but we have to be a 
  187.      * little careful at bootstrap */
  188.   LispObject ans;
  189.   int i;
  190.  
  191.   STACK_TMP(class);
  192.   if (class==NULL)
  193.     ans = allocate_nbytes(stacktop,sizeof(struct class_structure),TYPE_CLASS);
  194.   else 
  195.     ans = allocate_nbytes(stacktop,
  196.               sizeof(Object_t)+sizeof(LispObject)*intval(class->CLASS.local_count),
  197.               TYPE_CLASS);
  198.   UNSTACK_TMP(class);
  199.   lval_classof(ans) = class==NULL ? nil : class;
  200.  
  201.   (ans->CLASS).local_count = (class==NULL) ? nil : allocate_integer(stacktop,0);
  202.   (ans->CLASS).name = unbound;
  203.   (ans->CLASS).superclasses = nil;
  204.   (ans->CLASS).subclasses = nil;
  205.   (ans->CLASS).local_slot_list = nil;
  206.   (ans->CLASS).slot_list = nil;
  207.   (ans->CLASS).nonlocal_slot_list = nil;
  208.   (ans->CLASS).precedence = nil;
  209.   (ans->CLASS).spare1 = nil;
  210.   (ans->CLASS).spare2 = nil;
  211.   
  212.   if (class!=NULL)
  213.     {
  214.       for (i=N_SLOTS_IN_CLASS ; i<intval(class->CLASS.local_count) ; i++)
  215.     slotref(ans,i) = nil;
  216.     }
  217.   return ans;
  218. }
  219.  
  220. LispObject allocate_instance(LispObject *stacktop,LispObject class)
  221. {
  222.   LispObject ans;
  223.   int i;
  224.  
  225.   STACK_TMP(class);
  226.  
  227.   ans=allocate_nbytes(stacktop,sizeof(Object_t)
  228.               +sizeof(LispObject)*intval(class->CLASS.local_count),TYPE_INSTANCE);
  229.  
  230.   UNSTACK_TMP(class);
  231.   lval_classof(ans)=class;
  232.  
  233.   for (i=0; i<intval(class->CLASS.local_count); i++)
  234.     slotref(ans,i)=unbound;
  235.  
  236.   return ans;
  237. }
  238.  
  239. LispObject allocate_thread(LispObject *stacktop,int stack_size, 
  240.                int gc_stack_size, int nslots)
  241. { 
  242.   char* allocate_stack(LispObject *stacktop, int nbytes);
  243.   /* xxx: need extra slots hack */
  244.   LispObject ans,cont,data;
  245.   int extra;
  246.  
  247.   extra=nslots>0? nslots-N_SLOTS_IN_THREAD: 0;
  248.   cont = allocate_continue(stacktop);
  249.   STACK_TMP(cont);
  250.   data = allocate_string(stacktop,"",sizeof(struct thread_data));
  251.   memset(stringof(data),sizeof(struct thread_data), 0);
  252.  
  253.   STACK_TMP(data);
  254.  
  255.   ans=allocate_nbytes(stacktop,
  256.               sizeof(struct thread_structure)+extra*sizeof(LispObject),
  257.               TYPE_THREAD);
  258.  
  259.   lval_classof(ans) = Thread;
  260.   UNSTACK_TMP(data);
  261.   ans->THREAD.sysdata = data;
  262.   thread_stack_size(ans)=stack_size;
  263.   thread_gc_stack_size(ans) = gc_stack_size;
  264.  
  265.   ans->THREAD.fun = nil;
  266.   ans->THREAD.args = nil;
  267.   ans->THREAD.value = nil;
  268.  
  269.   thread_status(ans) = 0;
  270.  
  271.   ans->THREAD.thd_queue = nil;
  272.  
  273.   UNSTACK_TMP(cont);
  274.   ans->THREAD.state = cont;
  275.   thread_stack_base(ans) = NULL;
  276.   thread_gc_stack_base(ans) = NULL;
  277.  
  278.   ans->THREAD.state->CONTINUE.thread=ans;
  279.  
  280. #ifdef MACHINE_ANY
  281.  
  282.   thread_stack_base(ans) = (int *) allocate_stack(stacktop+1,stack_size);
  283.   (ans->THREAD.state)->CONTINUE.gc_stack_pointer =
  284.     thread_gc_stack_base(ans) =
  285.       (LispObject *) allocate_stack(stacktop+1,gc_stack_size*sizeof(LispObject));
  286.   
  287.   STACK_TMP(ans);
  288.   cont=EUCALL_2(Fn_cons,function_default_handler,nil);
  289.   UNSTACK_TMP(ans);
  290.   ans->THREAD.state->CONTINUE.handler_stack = cont;
  291.     
  292. #else
  293.  
  294.   thread_stack_base(ans) = NULL;
  295.   thread_gc_stack_base(ans) = NULL;
  296.   ans->THREAD.state->CONTINUE.gc_stack_pointer = NULL;
  297.   STACK_TMP(ans);
  298.   cont =  EUCALL_2(Fn_cons,function_default_handler,nil);
  299.   UNSTACK_TMP(ans);
  300.   ans->THREAD.state->CONTINUE.handler_stack = cont;
  301.  
  302.   ans->THREAD.sig_queue=nil;
  303. #endif
  304.   { /* ugh */
  305.     int i;
  306.     if (extra>0)
  307.       for(i=N_SLOTS_IN_THREAD; i<nslots; i++)
  308.     slotref(ans,i) = unbound;
  309.   }
  310.   return ans;
  311. }
  312.  
  313. LispObject allocate_vector(LispObject *stacktop,int size)
  314. {
  315.   LispObject ans;
  316.   int i;
  317.  
  318.   ans = allocate_nbytes(stacktop,sizeof(Object_t)+sizeof(int)+size*sizeof(LispObject),
  319.             TYPE_VECTOR);
  320.   
  321.   lval_classof(ans)= Vector;
  322.   
  323.   ans->VECTOR.length=size;
  324.  
  325.   for(i=0; i<size ; i++)
  326.     vref(ans,i)=nil;
  327.  
  328.   return ans;
  329. }
  330.  
  331. LispObject allocate_string(LispObject *stacktop, char *string, int len)
  332. {
  333.   LispObject ans;
  334.  
  335.   len++;
  336.   len=ROUND_ADDR(len);
  337.   ans = allocate_nbytes(stacktop,sizeof(Object_t)+sizeof(int)+len,
  338.             TYPE_STRING); 
  339.   
  340.   lval_classof(ans)=String;
  341.   ans->STRING.length= len;
  342.   stringof(ans)[len-1]=0;
  343.   strncpy(stringof(ans),string,len);
  344.  
  345.   return ans;
  346. }
  347.  
  348. LispObject allocate_symbol(LispObject *stacktop, char *str)
  349. {
  350.   int hash(char *); /* from tables.c */
  351.   extern int command_line_processors; /* yuck! */
  352.  
  353.   int hv;
  354.   LispObject ans;
  355.   LispObject tmp,tmp2;
  356.   
  357.   tmp=allocate_string(stacktop,str,strlen(str));
  358.   STACK_TMP(tmp);
  359.   hv=hash(str);
  360.   ans=allocate_nbytes(stacktop,sizeof(struct symbol_structure),TYPE_SYMBOL);
  361.   UNSTACK_TMP(tmp);
  362.  
  363.   lval_classof(ans)=Symbol;
  364.   ans->SYMBOL.pname=tmp;
  365. #ifdef MACHINE_SYSTEMV
  366.   STACK_TMP(ans);
  367.   tmp=allocate_vector(stacktop,command_line_processors);
  368.   STACK_TMP(tmp);
  369.   tmp2=allocate_vector(stacktop,command_line_processors);
  370.   UNSTACK_TMP(tmp);
  371.   UNSTACK_TMP(ans);
  372.   ans->SYMBOL.lmodule=tmp;
  373.   ans->SYMBOL.lvalue=tmp2;
  374. #else
  375.   ans->SYMBOL.lmodule=nil;
  376.   ans->SYMBOL.lvalue=nil;
  377. #endif
  378.   ans->SYMBOL.gvalue = NULL;
  379.   ans->SYMBOL.left = NULL;
  380.   ans->SYMBOL.right = NULL;
  381.   ans->SYMBOL.hash = hv;
  382.  
  383.   return ans;
  384. }
  385.  
  386. LispObject allocate_module_function(LispObject *stacktop,
  387.                     LispObject mod,LispObject name,
  388.                     LispObject (*fun)(LispObject*),
  389.                     int code)
  390. {
  391.   LispObject ans;
  392.  
  393.   STACK_TMP(name); STACK_TMP(mod);
  394.   ans=allocate_nbytes(stacktop,sizeof(struct c_function_structure),TYPE_C_FUNCTION);
  395.   UNSTACK_TMP(mod); UNSTACK_TMP(name);
  396.   lval_classof(ans) = CFunction;
  397.  
  398.   ans->C_FUNCTION.name = name;
  399.   ans->C_FUNCTION.home = mod;
  400.   ans->C_FUNCTION.argtype = code;
  401.   ans->C_FUNCTION.env = NULL;
  402.   ans->C_FUNCTION.setter = nil;
  403.  
  404.   ans->C_FUNCTION.func = fun;
  405.   
  406.   return ans;
  407. }
  408.  
  409. #ifdef NOLOWTAGINTS
  410. LispObject real_allocate_integer(LispObject *stacktop, int n)
  411. {
  412.   LispObject ans;
  413.  
  414.   if (n>=0 && n<STATIC_INTEGERS)
  415.     return vref(static_ints,n);
  416.  
  417.   ans=allocate_nbytes(stacktop,sizeof(struct integer_structure),TYPE_INT);
  418.  
  419.   lval_classof(ans)=Integer;
  420.   intval(ans)=n;
  421.  
  422.   return ans;
  423. }
  424. #endif
  425.  
  426. LispObject allocate_float(LispObject *stacktop,double x )
  427. {
  428.   LispObject ans;
  429.  
  430.   ans=allocate_nbytes(stacktop,sizeof(struct float_structure),TYPE_FLOAT);
  431.  
  432.   lval_classof(ans)=Real;
  433.   ans->FLOAT.fvalue=x;
  434.   
  435.   return ans;
  436.   
  437. }
  438.  
  439. static LispObject real_allocate_char(LispObject *stacktop, int x)
  440. {
  441.   LispObject ans;
  442.  
  443.   ans=allocate_nbytes(stacktop,sizeof(struct character_structure),
  444.               TYPE_CHAR);
  445.   lval_classof(ans)=Character;
  446.   ans->CHAR.font=0;
  447.   ans->CHAR.code=x;
  448.   return ans;
  449.   
  450. }
  451.  
  452. LispObject allocate_char(LispObject *stacktop,int x)
  453. {
  454.   if (x<0 || x>MAX_CHAR)
  455.     return (real_allocate_char(stacktop,x));
  456.   else
  457.     return vref(static_chars,x);
  458. }
  459.  
  460. LispObject allocate_continue(LispObject *stacktop)
  461. {
  462.  
  463.   LispObject ans;
  464.  
  465.   ans=allocate_nbytes(stacktop,sizeof(struct continue_structure),TYPE_CONTINUE);
  466.  
  467.   lval_classof(ans) = Continue;
  468.  
  469.   (ans->CONTINUE).thread = nil;
  470.  
  471.   (ans->CONTINUE).value = nil;
  472.   (ans->CONTINUE).target = nil;
  473.  
  474.   /*  (ans->CONTINUE).machine_state; */
  475.   (ans->CONTINUE).gc_stack_pointer = NULL;
  476.   (ans->CONTINUE).dynamic_env = NULL;
  477.   (ans->CONTINUE).last_continue = nil;
  478.   (ans->CONTINUE).handler_stack = nil;
  479.  
  480.   (ans->CONTINUE).dp = nil;
  481.  
  482.   (ans->CONTINUE).live = FALSE;
  483.   (ans->CONTINUE).unwind = FALSE;  
  484.   
  485.   return ans;
  486. }
  487.  
  488. LispObject allocate_env(LispObject *stacktop, LispObject name, 
  489.             LispObject value, LispObject prev)
  490. {
  491.   LispObject ans;
  492.  
  493.   STACK_TMP(prev); STACK_TMP(name); STACK_TMP(value);
  494.   ans=allocate_nbytes(stacktop,sizeof(struct env_structure),TYPE_ENV);
  495.   UNSTACK_TMP(value); UNSTACK_TMP(name); UNSTACK_TMP(prev);
  496.   lval_classof(ans) = nil; /* ? */
  497.  
  498.   ans->ENV.variable = name;
  499.   ans->ENV.value = value;
  500.   ans->ENV.next = prev;
  501.  
  502.   return ans;
  503. }
  504.  
  505. LispObject allocate_envimut(LispObject *stacktop, LispObject name, LispObject value, LispObject prev)
  506. {
  507.   LispObject ans;
  508.   
  509.   ans=allocate_env(stacktop,name,value,prev);
  510.   
  511.   lval_typeof(ans)=TYPE_FIXENV;
  512.   return ans;
  513. }
  514.  
  515. LispObject allocate_special(LispObject *stacktop, 
  516.                 LispObject name, 
  517.                 LispObject (*fn)(LispObject *))
  518. {
  519.   LispObject ans;
  520.  
  521.   STACK_TMP(name);
  522.   ans=allocate_nbytes(stacktop,sizeof(struct special_structure),TYPE_SPECIAL);
  523.   UNSTACK_TMP(name);
  524.  
  525.   lval_classof(ans) = Object;
  526.  
  527.   ans->SPECIAL.name  = name;
  528.   ans->SPECIAL.env   = NULL;
  529.   ans->SPECIAL.func  = fn;
  530.  
  531.   return(ans);
  532.  
  533. }
  534.  
  535.  
  536. LispObject allocate_i_function(LispObject *stacktop, LispObject mod, 
  537.                    LispObject env, int argcode)
  538. {
  539.   LispObject ans;
  540.  
  541.   STACK_TMP(mod); STACK_TMP(env);
  542.   ans=allocate_nbytes(stacktop,sizeof(struct i_function_structure),TYPE_I_FUNCTION);
  543.  
  544.   UNSTACK_TMP(env); UNSTACK_TMP(mod);
  545.   lval_classof(ans)=IFunction;
  546.   ans->I_FUNCTION.name=nil;
  547.   ans->I_FUNCTION.home = mod;
  548.   ans->I_FUNCTION.env = env;
  549.   ans->I_FUNCTION.argtype = argcode;
  550.   
  551.   ans->I_FUNCTION.bvl = nil;
  552.   ans->I_FUNCTION.body = nil;
  553.  
  554.   return ans;
  555. }
  556.  
  557.  
  558. LispObject allocate_i_module(LispObject *stacktop, LispObject name)
  559. {
  560.   LispObject ans;
  561.  
  562.   STACK_TMP(name);
  563.   ans=allocate_nbytes(stacktop,sizeof(struct i_module_structure), TYPE_I_MODULE);
  564.   UNSTACK_TMP(name);
  565.  
  566.   lval_classof(ans)=Object;
  567.   ans->I_MODULE.name = name;
  568.   ans->I_MODULE.home = nil;
  569.   ans->I_MODULE.exported_names = nil;
  570.   ans->I_MODULE.bounce_flag = nil;
  571.   ans->I_MODULE.imported_modules = nil; /* HACK !!! GC */
  572.   ans->I_MODULE.bindings = nil;
  573.   
  574.   return ans;
  575. }
  576.  
  577. #if (defined(WITH_BSD_SOCKETS) || defined(WITH_SYSTEMV_SOCKETS))
  578.  
  579. LispObject allocate_listener(LispObject *stacktop)
  580. {
  581.   LispObject ans;
  582.  
  583.   ans=allocate_nbytes(stacktop,sizeof(struct listener_structure), TYPE_LISTENER);
  584.   lval_classof(ans)=nil; /* will be set later */
  585.   return ans;
  586. }
  587.  
  588.  
  589. LispObject allocate_socket(LispObject *stacktop)
  590. {
  591.   LispObject ans;
  592.   
  593.   ans=allocate_nbytes(stacktop,sizeof(struct socket_structure), TYPE_SOCKET);
  594.   lval_classof(ans)=nil; /* will be set later */
  595.   return ans;
  596. }
  597. #endif
  598.  
  599. LispObject allocate_semaphore(LispObject *stacktop)
  600. {
  601.   LispObject ans;
  602.   
  603.   ans=allocate_nbytes(stacktop,sizeof(struct semaphore_structure), TYPE_SEMAPHORE);
  604.  
  605.   lval_classof(ans)=Object; /* Ugh */
  606.   system_allocate_semaphore(&(ans->SEMAPHORE.semaphore));
  607.  
  608.   return ans;
  609. }
  610.  
  611. LispObject allocate_static_vector(LispObject *stacktop,int nslots)
  612. {
  613.   LispObject space;
  614.   int i;
  615.  
  616.   space=(LispObject) allocate_space(stacktop,sizeof(Object_t)+sizeof(int)+nslots*sizeof(LispObject));
  617.   
  618.   for (i=0; i<nslots; i++)
  619.     vref(space,i)=NULL;
  620.  
  621.   lval_typeof(space)=TYPE_VECTOR|STATIC_TYPE;
  622.   lval_classof(space)=Vector;
  623.   gcof(space)=current_space();
  624.   ageof(space)=0;
  625.   space->VECTOR.length=nslots;
  626.  
  627.   return(space);
  628. }
  629.  
  630. LispObject allocate_static_string(LispObject *stacktop, int size)
  631. {
  632.   LispObject space;
  633.   size++;
  634.   size=ROUND_ADDR(size);
  635.   space=(LispObject) allocate_space(stacktop,sizeof(Object_t)+sizeof(int)+size);
  636.   
  637.   lval_typeof(space)=TYPE_STRING|STATIC_TYPE;
  638.   lval_classof(space)=String;
  639.   gcof(space)=current_space();
  640.   ageof(space)=0;
  641.   space->STRING.length=size;
  642.   return (space);
  643. }
  644.  
  645.  
  646. void allocate_static_integers(LispObject *stacktop)
  647. {
  648. #ifdef NOLOWTAGINTS
  649.   int i;
  650.  
  651.   static_ints=allocate_static_vector(stacktop,STATIC_INTEGERS);
  652.   for (i=0; i<STATIC_INTEGERS; i++)
  653.     {        /* alloc a big integer, then 'fix' it */
  654.       LispObject xx=real_allocate_integer(stacktop,STATIC_INTEGERS);
  655.       intval(xx)=i;
  656.       vref(static_ints,i)=xx;
  657.     }
  658.  
  659.   add_root(&static_ints);
  660. #endif
  661. }
  662.  
  663. void allocate_static_chars(LispObject *stacktop)
  664. {
  665.   int i;
  666.   static_chars=allocate_static_vector(stacktop,MAX_CHAR+1);
  667.   
  668.   for (i=0; i<MAX_CHAR+1 ; i++)
  669.     {
  670.       LispObject c=real_allocate_char(stacktop,i);
  671.       vref(static_chars,i)=c;
  672.     }
  673.   add_root(&static_chars);
  674. }
  675.  
  676. typedef struct free_list_struct
  677. {
  678.   int size;
  679.   struct free_list_struct *next;
  680. } *FreeList;
  681.  
  682. static SYSTEM_GLOBAL(FreeList, stack_chain);
  683.  
  684. static int free_count;
  685. static int nfrags;
  686.  
  687. #ifdef CGC
  688. static void initialise_stack_space(int stackspace)
  689. {
  690.   gc_init();
  691. }
  692. #else
  693. static void initialise_stack_space(int stackspace)
  694. {
  695.   char *space;
  696.   int allocated=0;
  697.   FreeList *chain_end;
  698.   
  699.   SYSTEM_INITIALISE_GLOBAL(FreeList,stack_chain,NULL);
  700.  
  701.   chain_end=&SYSTEM_GLOBAL_VALUE(stack_chain);
  702.   nfrags=0;
  703.   while (allocated < stackspace)
  704.     {
  705.       int sz;
  706.       
  707.       sz=stackspace-allocated;
  708.       if (sz>SYSTEM_MAX_SHARED_SIZE)
  709.     sz=SYSTEM_MAX_SHARED_SIZE;
  710.  
  711.       space=system_malloc(sz);
  712.  
  713.       *chain_end=(FreeList)space;
  714.  
  715.       (*chain_end)->size= sz - sizeof(*chain_end);
  716.       (*chain_end)->next= NULL;
  717.       chain_end=&((*chain_end)->next);
  718.       free_count+=SYSTEM_GLOBAL_VALUE(stack_chain)->size;
  719.       
  720.       allocated+=sz;
  721.       nfrags++;
  722.     }
  723. }
  724. #endif
  725.  
  726. void show_stack_space()
  727. {
  728.   fprintf(stderr,"Stack space: %d remaining, %d fragments\n",free_count, nfrags);
  729. }
  730.  
  731. /* use header as pointer to prevously allocated stack */
  732.  
  733. #ifdef CGC
  734. char* allocate_stack(LispObject *stacktop, int nbytes)
  735. {
  736.   return (char *)gc_malloc(nbytes);
  737. }
  738. #else
  739. char* allocate_stack(LispObject *stacktop, int nbytes)
  740. {
  741.   FreeList oldstack;
  742.   FreeList *walker;
  743.   char *ret;
  744.  
  745.   if (nbytes==0)
  746.     return NULL;
  747.  
  748.   system_open_semaphore(stacktop,&S_G_V(GC_sem)); 
  749.   walker= &SYSTEM_GLOBAL_VALUE(stack_chain);
  750.   nbytes=ROUND_ADDR(nbytes);
  751.  
  752.   free_count -= nbytes;
  753.  
  754.   while ( (*walker)!=NULL)
  755.     {
  756.       if ((*walker)->size+sizeof(*walker)==nbytes)
  757.     { 
  758.       ret= (char*) (*walker);
  759.       *walker=(*walker)->next;
  760.       nfrags--;
  761.       FPRINTF_GC_BUG((stderr,"{Cool stack: %x->%x}",ret,ret+nbytes));
  762.       GC_BUG(memset(ret,'S',nbytes));
  763.       system_close_semaphore(&S_G_V(GC_sem)); 
  764.       return ret;
  765.     }
  766.       if ((*walker)->size<nbytes)
  767.     {
  768.       FPRINTF_GC_BUG((stderr,"[Looking at: %x->%x (%d)]",*walker,(*walker)+(*walker)->size,
  769.               (*walker)->size));      
  770.       walker = &((*walker)->next);
  771.     }
  772.       else
  773.     {
  774.       ret= ((char *)((*walker)+1))+((*walker)->size-nbytes);
  775.       (*walker)->size=(*walker)->size-nbytes;
  776.       GC_BUG(memset(ret,'S',nbytes));
  777.       FPRINTF_GC_BUG((stderr,"{Alloc stack: %x->%x}",ret,ret+nbytes));
  778.       system_close_semaphore(&S_G_V(GC_sem)); 
  779.       return ret;
  780.     }
  781.     }
  782.   fprintf(stderr,"alloc stack: stack wimped out (%d remaining --- probably)\n",free_count);
  783.   system_close_semaphore(&S_G_V(GC_sem)); 
  784.   return NULL;
  785. }
  786. #endif
  787.  
  788. #ifdef CGC
  789. void deallocate_stack(LispObject *stacktop, char *addr,int nbytes)
  790. {
  791.  /* could use gc_free(object) here? */
  792. }
  793. #else
  794. void deallocate_stack(LispObject *stacktop, char *addr,int nbytes)
  795. {
  796.   FreeList old, walker;
  797.   /* Too damm lazy */
  798.   nbytes=ROUND_ADDR(nbytes);
  799.  
  800.   
  801.   system_open_semaphore(stacktop,&S_G_V(GC_sem)); 
  802.   walker=SYSTEM_GLOBAL_VALUE(stack_chain);
  803.   FPRINTF_GC_BUG((stderr,"{dealloc: %x->%x [%d]",addr,addr+nbytes,nbytes));
  804.   while (   ((char *)walker->next) < addr
  805.      && walker->next!=NULL)
  806.     {
  807.       /* sanity check */
  808. #if 0    /* sun allocates shared memory in the wrong order */
  809.       if (walker >= walker->next)
  810.     { 
  811.       FPRINTF_GC_BUG((stderr,"Rats--- strange chain\n"));
  812.       system_lisp_exit(1);
  813.     }
  814. #endif
  815.       walker=walker->next;
  816.     }
  817.   /* 3 cases --- at the start */
  818.   if ( ((char *)(walker+1)) + walker->size == addr)
  819.     {
  820.       /* side check for end */
  821.  
  822.       if (walker->next!=NULL && addr+nbytes == (char *) walker->next)
  823.     {
  824.       walker->size = walker->size+nbytes
  825.         +sizeof(*walker)
  826.           +walker->next->size;
  827.       walker->next=walker->next->next;
  828.       free_count+=nbytes+sizeof(*walker);
  829.       nfrags--;
  830.       FPRINTF_GC_BUG((stderr,"Filler}"));
  831.     }
  832.       else    
  833.     {
  834.       walker->size=walker->size+nbytes;
  835.       free_count+=nbytes;
  836.       FPRINTF_GC_BUG((stderr,"Start}"));
  837.     }
  838.       system_close_semaphore(&S_G_V(GC_sem)); 
  839.       return;
  840.     }
  841.   /* at the end */
  842.   if ( walker->next!=NULL && addr+nbytes == (char *) walker->next)
  843.     {
  844.       old=walker->next;
  845.       walker->next=(FreeList) addr;
  846.       walker->next->size=nbytes+old->size;
  847.       walker->next->next=old->next;
  848.       free_count+=nbytes;
  849.       FPRINTF_GC_BUG((stderr,"End}"));
  850.       system_close_semaphore(&S_G_V(GC_sem)); 
  851.       return;
  852.     }
  853.   /* in the middle */
  854.   old=walker->next;      
  855.   walker->next=(FreeList) addr;
  856.   walker->next->next=old;
  857.   walker->next->size=nbytes-sizeof(*walker);
  858.   nfrags++;
  859.   free_count+=nbytes-sizeof(*walker);
  860.   FPRINTF_GC_BUG((stderr,"Middle}"));
  861.   system_close_semaphore(&S_G_V(GC_sem)); 
  862. }
  863. #endif 
  864.   
  865. int dump_obj(unsigned int *x,int s)
  866. {
  867.   int i;
  868.   
  869.   if (s>200) s=16;
  870.  
  871.   for (i=0; i<s ; i+=4)
  872.     fprintf(stderr,"0x%x: %x %x %x %x\n",
  873.         x+i,
  874.         (int)*(x+i),(int)*(x+i+1),(int)*(x+i+2),(int)*(x+i+3));
  875.   return s;
  876. }
  877.   
  878.